home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / x11 / x-mouse.el < prev    next >
Encoding:
Text File  |  1995-08-18  |  15.0 KB  |  414 lines
  1. ;; Mouse support for X window system.
  2. ;; Copyright (C) 1985, 1992, 1993, 1994 Free Software Foundation, Inc.
  3.  
  4. ;; This file is part of XEmacs.
  5.  
  6. ;; XEmacs is free software; you can redistribute it and/or modify it
  7. ;; under the terms of the GNU General Public License as published by
  8. ;; the Free Software Foundation; either version 2, or (at your option)
  9. ;; any later version.
  10.  
  11. ;; XEmacs is distributed in the hope that it will be useful, but
  12. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14. ;; General Public License for more details.
  15.  
  16. ;; You should have received a copy of the GNU General Public License
  17. ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  18. ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. (require 'mouse)
  21.  
  22. ;;(define-key global-map 'button2 'x-set-point-and-insert-selection)
  23. ;; This is reserved for use by Hyperbole.
  24. ;;(define-key global-map '(shift button2) 'x-mouse-kill)
  25. (define-key global-map '(control button2) 'x-set-point-and-move-selection)
  26.  
  27. (setq mouse-yank-function 'x-yank-function)
  28.  
  29. (defvar inhibit-help-echo nil
  30.   "Inhibits display of `help-echo' extent properties in the minibuffer.")
  31.  
  32. (defun x-mouse-kill (event)
  33.   "Kill the text between the point and mouse and copy it to the clipboard and
  34. to the cut buffer"
  35.   (interactive "@e")
  36.   (let ((old-point (point)))
  37.     (mouse-set-point event)
  38.     (let ((s (buffer-substring old-point (point))))
  39.       (x-own-clipboard s)
  40.       (x-store-cutbuffer s))
  41.     (kill-region old-point (point))))
  42.  
  43. (defun x-yank-function ()
  44.   "Insert the current X selection or, if there is none, insert the X cutbuffer.
  45. A mark is pushed, so that the inserted text lies between point and mark."
  46.   (push-mark)
  47.   (if (region-active-p)
  48.        (insert (extent-string zmacs-region-extent))
  49.     (x-insert-selection t)))
  50.  
  51. (defun x-insert-selection (&optional check-cutbuffer-p move-point-event)
  52.   "Insert the current selection into buffer at point."
  53.   (interactive "P")
  54.   (let ((text (if check-cutbuffer-p
  55.           (or (condition-case () (x-get-selection) (error ()))
  56.               (x-get-cutbuffer)
  57.               (error "No selection or cut buffer available"))
  58.         (x-get-selection))))
  59.     (cond (move-point-event
  60.        (mouse-set-point move-point-event)
  61.        (push-mark (point)))
  62.       ((interactive-p)
  63.        (push-mark (point))))
  64.     (insert text)
  65.     ))
  66.  
  67. (make-obsolete 'x-set-point-and-insert-selection 'mouse-yank)
  68. (defun x-set-point-and-insert-selection (event)
  69.   "Set point where clicked and insert the primary selection or the cut buffer."
  70.   (interactive "e")
  71.   (let ((mouse-yank-at-point nil))
  72.     (mouse-yank event)))
  73.  
  74. (defun x-set-point-and-move-selection (event)
  75.   "Set point where clicked and move the selected text to that location."
  76.   (interactive "e")
  77.   ;; Don't try to move the selection if x-kill-primary-selection if going
  78.   ;; to fail; just let the appropriate error message get issued. (We need
  79.   ;; to insert the selection and set point first, or the selection may
  80.   ;; get inserted at the wrong place.)
  81.   (and (x-selection-owner-p)
  82.        primary-selection-extent
  83.        (x-insert-selection t event))
  84.   (x-kill-primary-selection))
  85.  
  86. (defun mouse-track-and-copy-to-cutbuffer (event)
  87.   "Make a selection like `mouse-track', but also copy it to the cutbuffer."
  88.   (interactive "e")
  89.   (mouse-track event)
  90.   (cond
  91.    ((null primary-selection-extent)
  92.     nil)
  93.    ((consp primary-selection-extent)
  94.     (save-excursion
  95.       (set-buffer (extent-buffer (car primary-selection-extent)))
  96.       (x-store-cutbuffer
  97.        (mapconcat
  98.     'identity
  99.     (extract-rectangle
  100.      (extent-start-position (car primary-selection-extent))
  101.      (extent-end-position (car (reverse primary-selection-extent))))
  102.     "\n"))))
  103.    (t
  104.     (save-excursion
  105.       (set-buffer (extent-buffer primary-selection-extent))
  106.       (x-store-cutbuffer
  107.        (buffer-substring (extent-start-position primary-selection-extent)
  108.              (extent-end-position primary-selection-extent)))))))
  109.  
  110.  
  111. ;;; Pointer shape.
  112. ;;; This code doesn't allow the mouse cursor and mouse color to be per-frame,
  113. ;;; but that wouldn't be hard to do.
  114.  
  115. ;;; #### Should also allow for a cursor object here.
  116.  
  117. (defvar x-pointer-shape nil
  118.   "*The shape of the mouse-pointer when over text.
  119.  
  120. This string may be any of the standard cursor names from appendix B 
  121. of the Xlib manual (also known as the file <X11/cursorfont.h>) minus 
  122. the XC_ prefix, or it may be a font name and glyph index of the form 
  123. \"FONT fontname index [[font] index]\", or it may be the name of a
  124. bitmap file acceptable to XmuLocateBitmapFile().  If it is a bitmap
  125. file, and if a bitmap file whose name is the name of the cursor with
  126. \"msk\" exists, then it is used as the mask.  For example, a pair of
  127. files may be named \"cursor.xbm\" and \"cursor.xbmmsk\".")
  128.  
  129. (defvar x-nontext-pointer-shape nil
  130.   "*The shape of the mouse-pointer when over a buffer, but not over text.  
  131. If this is nil, then `x-pointer-shape' is used.")
  132.  
  133. (defvar x-mode-pointer-shape nil
  134.   "*The shape of the mouse-pointer when over the modeline.
  135. If this is nil, then either `x-nontext-pointer-shape' or `x-pointer-shape'
  136. will be used.")
  137.  
  138. (defvar x-selection-pointer-shape nil
  139.   "*The shape of the mouse-pointer when over a selectable text region.")
  140.  
  141. (defvar x-busy-pointer-shape nil
  142.   "*The shape of the mouse-pointer when Emacs is busy.")
  143.  
  144. (defvar x-toolbar-pointer-shape nil
  145.   "*The shape of the mouse-pointer when over a toolbar.")
  146.  
  147. (defvar x-pointer-foreground-color nil
  148.   "*The foreground color of the mouse pointer.")
  149.  
  150. (defvar x-pointer-background-color nil
  151.   "*The background color of the mouse pointer.")
  152.  
  153. (defvar x-pointer-cache nil)
  154. (defvar x-pointer-cache-key (make-vector 4 nil))
  155.  
  156. (defun x-pointer-cache (name fg bg device)
  157.   ;; both must be specified, or neither
  158.   (or (eq (null fg) (null bg))
  159.       (setq fg (or fg
  160.            (color-instance-name (face-foreground 'default device)))
  161.         bg (or bg
  162.            (color-instance-name (face-background 'default device)))))
  163.   (aset x-pointer-cache-key 0 name)
  164.   (aset x-pointer-cache-key 1 fg)
  165.   (aset x-pointer-cache-key 2 bg)
  166.   (aset x-pointer-cache-key 3 device)
  167.   (let (pointer)
  168.     (or (setq pointer (cdr (assoc x-pointer-cache-key x-pointer-cache)))
  169.     (let (tail)
  170.       (setq x-pointer-cache
  171.         (cons (cons (copy-sequence x-pointer-cache-key)
  172.                 (make-cursor name fg bg device))
  173.               x-pointer-cache))
  174.       (setq pointer (cdr (car x-pointer-cache)))
  175.       (if (setq tail (nthcdr 10 x-pointer-cache))
  176.           (setcdr tail nil))))
  177.     pointer))
  178.  
  179. (defvar last-help-echo-object nil)
  180. (defvar help-echo-owns-message nil)
  181.  
  182. (defun clear-help-echo (&optional ignored-frame)
  183.   (if help-echo-owns-message
  184.       (progn
  185.     (setq help-echo-owns-message nil
  186.           last-help-echo-object nil)
  187.     (clear-message 'help-echo))))
  188.  
  189. (defun show-help-echo (mess)
  190.   ;; (clear-help-echo)
  191.   (setq help-echo-owns-message t)
  192.   (display-message 'help-echo mess))
  193.  
  194. (add-hook 'mouse-leave-frame-hook 'clear-help-echo)
  195.  
  196. (defun x-track-pointer (event)
  197.   "For use as the value of `mouse-motion-handler'.
  198. This implements `x-pointer-shape' and related variables,
  199. as well as extent highlighting, and `mode-motion-hook'."
  200.   (let* ((frame (or (event-frame event) (selected-frame)))
  201.      (device (frame-device frame))
  202.      (buffer (event-buffer event))
  203.      (point (and buffer (event-point event)))
  204.      (extent (and point (extent-at point buffer 'highlight)))
  205.      (glyph (event-glyph-extent event))
  206.      (button (event-toolbar-button event))
  207.      (help (or (and glyph (extent-property glyph 'help-echo) glyph)
  208.            (and button (not (null (toolbar-button-help-string button)))
  209.             button)
  210.            (and point
  211.             (condition-case nil
  212.                 (extent-at point buffer 'help-echo)
  213.               (error nil)))))
  214.      (var (cond ((and extent x-selection-pointer-shape)
  215.              'x-selection-pointer-shape)
  216.             ;; Checking if button is non-nil is not sufficent
  217.             ;; since the pointer could be over a blank portion
  218.             ;; of the toolbar.
  219.             ((event-over-toolbar-p event) 'x-toolbar-pointer-shape)
  220.             (glyph 'x-selection-pointer-shape)
  221.             (point 'x-pointer-shape)
  222.             ((event-over-modeline-p event) 'x-mode-pointer-shape)
  223.             (buffer
  224.              (cond (x-nontext-pointer-shape 'x-nontext-pointer-shape)
  225.                (x-pointer-shape 'x-pointer-shape)))
  226.             (t (cond (x-mode-pointer-shape 'x-mode-pointer-shape)
  227.                  (x-nontext-pointer-shape 'x-nontext-pointer-shape)
  228.                  (x-pointer-shape 'x-pointer-shape)))))
  229.      pointer scrollbar-pointer)
  230.     (condition-case c
  231.     (progn
  232.       (setq pointer (x-pointer-cache (symbol-value var)
  233.                       x-pointer-foreground-color
  234.                       x-pointer-background-color
  235.                       device))
  236.       (x-set-frame-pointer frame pointer))
  237.       (error
  238.        (x-track-pointer-damage-control c var device)))
  239.     (condition-case c
  240.     (progn
  241.       (setq scrollbar-pointer
  242.         (if x-scrollbar-pointer-shape
  243.             (x-pointer-cache x-scrollbar-pointer-shape
  244.                      x-pointer-foreground-color
  245.                      x-pointer-background-color
  246.                      device)
  247.           pointer))
  248.       (x-set-scrollbar-pointer frame scrollbar-pointer))
  249.       (error
  250.        (x-track-pointer-damage-control c 'x-scrollbar-pointer-shape device)))
  251.  
  252.     ;; If last-pressed-toolbar-button is not nil, then check and see
  253.     ;; if we have moved to a new button and adjust the down flags
  254.     ;; accordingly.
  255.     (if toolbar-active
  256.     (if (not (eq last-pressed-toolbar-button button))
  257.         (progn
  258.           (release-previous-toolbar-button event)
  259.           (and button (press-toolbar-button event)))))
  260.       
  261.     (cond (extent (highlight-extent extent t))
  262.       (glyph (highlight-extent glyph t))
  263.       (t (highlight-extent nil nil)))
  264.     (cond ((extentp help)
  265.            (or inhibit-help-echo
  266.                (eq help last-help-echo-object) ;save some time
  267.                (let ((hprop (extent-property help 'help-echo)))
  268.                  (setq last-help-echo-object help)
  269.                  (or (stringp hprop)
  270.                      (setq hprop (funcall hprop help)))
  271.                  (and hprop (show-help-echo hprop)))))
  272.       ((and (toolbar-button-p help) (toolbar-button-enabled-p help))
  273.        (or (not toolbar-help-enabled)
  274.            (eq help last-help-echo-object) ;save some time
  275.            (let ((hstring (toolbar-button-help-string button)))
  276.          (setq last-help-echo-object help)
  277.          (or (stringp hstring)
  278.              (setq hstring (funcall hstring help)))
  279.          (show-help-echo hstring))))
  280.           (last-help-echo-object
  281.        (clear-help-echo)))
  282.     (if mouse-grabbed-buffer (setq buffer mouse-grabbed-buffer))
  283.     (if buffer
  284.     (save-window-excursion
  285.       (set-buffer buffer)
  286.       (run-hook-with-args 'mode-motion-hook event)
  287.  
  288.       ;; If the mode-motion-hook created a highlightable extent around
  289.       ;; the mouse-point, highlight it right away.  Otherwise it wouldn't
  290.       ;; be highlighted until the *next* motion event came in.
  291.       (if (and point
  292.            (null extent)
  293.            (setq extent (extent-at point
  294.                        (event-buffer event) ; not buffer
  295.                        'highlight)))
  296.           (highlight-extent extent t)))))
  297.   nil)
  298.  
  299. (defun x-track-pointer-damage-control (c var device)
  300.   ;; When x-set-frame-pointer signals an error, this function tries to figure
  301.   ;; out why, and undo the damage so that an error isn't signalled every time
  302.   ;; the mouse moves.
  303.   (cond ((and (stringp (nth 1 c))
  304.           (or (string= (nth 1 c) "unknown cursor")
  305.           (string-match "xpm\\|XPM\\|pixmap\\|bitmap" (nth 1 c))))
  306.      (set var nil)
  307.      (error "%S was %S, which is an invalid X cursor name.  Reset."
  308.         var (nth 2 c)))
  309.     ((string= (nth 1 c) "unrecognised color")
  310.      (if (not (valid-color-name-p x-pointer-foreground-color device))
  311.          (setq var 'x-pointer-foreground-color)
  312.        (if (not (valid-color-name-p x-pointer-background-color device))
  313.            (setq var 'x-pointer-background-color)
  314.          (error "got %S and I don't know why!" c)))
  315.      (set var nil)
  316.      (error "%S was %S, which was an invalid color name.  Reset."
  317.         var (nth 2 c)))
  318.     ((string= (nth 1 c) "couldn't allocate color")
  319.      (cond ((string= (nth 2 c) x-pointer-foreground-color)
  320.         (setq var 'x-pointer-foreground-color))
  321.            ((string= (nth 2 c) x-pointer-background-color)
  322.         (setq var 'x-pointer-background-color))
  323.            (t (error "got %S and I don't know why!" c)))
  324.      (set var nil)
  325.      (error "%S was %S, which cannot be allocated.  Reset."
  326.         var (nth 2 c)))
  327.     ((eq (car c) 'wrong-type-argument)
  328.      (let ((rest '(x-pointer-foreground-color x-pointer-background-color
  329.                x-pointer-shape x-nontext-pointer-shape
  330.                x-mode-pointer-shape x-scrollbar-pointer-shape)))
  331.        (while rest
  332.          (if (and (symbol-value (car rest))
  333.               (not (stringp (symbol-value (car rest)))))
  334.          (progn
  335.            (set (car rest) nil)
  336.            (error "%S was %S, not a string.  Reset." (car rest)
  337.               (nth 2 c))))
  338.          (setq rest (cdr rest)))
  339.        (error "got %S and I don't know why!" c)))
  340.     (t (signal (car c) (cdr c)))))
  341.  
  342.  
  343. ;;; GC pointer shape
  344.  
  345. ;; For the mystified out there, the GC pointer is stored in the variable
  346. ;; `gc-message', which is defined in alloc.c.  If the value of this is
  347. ;; a cursor, the function x_show_gc_cursor(), defined in xfns.c, is called
  348. ;; at the beginning of garbage collection.
  349.  
  350. (defun x-set-pointer-for-gc ()
  351.   (if (or (not (eq 'x (device-type (selected-device))))
  352.       (null x-gc-pointer-shape))
  353.       (setq gc-message nil)
  354.     ;; else
  355.     (condition-case error
  356.     (setq gc-message (x-pointer-cache x-gc-pointer-shape
  357.                       x-pointer-foreground-color
  358.                       x-pointer-background-color
  359.                       (selected-device)))
  360.       (error
  361.        ;; This conses a little bit but not much.  Should be ok.
  362.        (setq gc-message nil)
  363.        (let ((b (get-buffer-create " *gc-pointer-error*")))
  364.      (save-excursion
  365.        (set-buffer b)
  366.        (erase-buffer)
  367.        (insert "Garbage collecting... ERROR setting GC pointer: ")
  368.        (display-error error b)
  369.        (display-warning 'pointer (buffer-string)))
  370.      (kill-buffer b))))))
  371.  
  372. (add-hook 'pre-gc-hook 'x-set-pointer-for-gc)
  373.  
  374.  
  375. (defvar x-pointers-initialized nil)
  376.  
  377. (defun x-init-pointer-shape (device)
  378.   "Initializes the mouse-pointers of the given device from the resource
  379. database."
  380.   ;; #### nyet nyet nyet!  Need to extend cursors and x-pointer-shape
  381.   ;; to be device-specific.
  382.   (if x-pointers-initialized  ; only do it when the first device is created
  383.       nil
  384.     (setq x-pointer-shape
  385.       (or (x-get-resource "textPointer" "Cursor" 'string device)
  386.           "xterm"))
  387.     (setq x-selection-pointer-shape
  388.       (or (x-get-resource "selectionPointer" "Cursor" 'string device)
  389.           "top_left_arrow"))
  390.     (setq x-nontext-pointer-shape
  391.       (or (x-get-resource "spacePointer" "Cursor" 'string device)
  392.           "xterm")) ; was "crosshair"
  393.     (setq x-mode-pointer-shape
  394.       (or (x-get-resource "modeLinePointer" "Cursor" 'string device)
  395.           "sb_v_double_arrow"))
  396.     (setq x-gc-pointer-shape
  397.       (or (x-get-resource "gcPointer" "Cursor" 'string device)
  398.           "watch"))
  399.     (setq x-scrollbar-pointer-shape
  400.       (or (x-get-resource "scrollbarPointer" "Cursor" 'string device)
  401.           "top_left_arrow"))
  402.     (setq x-busy-pointer-shape
  403.       (or (x-get-resource "busyPointer" "Cursor" 'string device)
  404.           "watch"))
  405.     (setq x-toolbar-pointer-shape
  406.       (or (x-get-resource "toolBarPointer" "Cursor" 'string device)
  407.           "left_ptr"))
  408.     (setq x-pointer-foreground-color
  409.       (x-get-resource "pointerColor" "Foreground" 'string device))
  410.     (setq x-pointer-background-color
  411.       (x-get-resource "pointerBackground" "Background" 'string device))
  412.     (setq x-pointers-initialized t))
  413.   nil)
  414.